'Attribute VB_Name = "VBA_MOD"
Option Explicit
'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Scripting Runtime
'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Visual basic for application Extensibility 5.3


Private Const BEG_SUB = "Sub "
Private Const END_SUB = "End Sub"
Private Const BEG_PB_SUB = "Public Sub "
Private Const BEG_PV_SUB = "Private Sub "
Private Const BEG_FR_SUB = "Friend Sub "
Private Const BEG_PB_ST_SUB = "Public Static Sub "
Private Const BEG_PV_ST_SUB = "Private Static Sub "
Private Const BEG_FR_ST_SUB = "Friend Static Sub "

Private Const BEG_FUN = "Function "
Private Const END_FUN = "End Function"
Private Const BEG_PB_FUN = "Public Function "
Private Const BEG_PV_FUN = "Private Function "
Private Const BEG_FR_FUN = "Friend Function "
Private Const BEG_PB_ST_FUN = "Public Static Function "
Private Const BEG_PV_ST_FUN = "Private Static Function "
Private Const BEG_FR_ST_FUN = "Friend Static Function "

Private Const BEG_PROP = "Property "
Private Const END_PROP = "End Property"
Private Const BEG_PB_PROP = "Public Property "
Private Const BEG_PV_PROP = "Private Property "
Private Const BEG_FR_PROP = "Friend Property "
Private Const BEG_PB_ST_PROP = "Public Static Property "
Private Const BEG_PV_ST_PROP = "Private Static Property "
Private Const BEG_FR_ST_PROP = "Friend Static Property "

Private Const BEG_ENUM = "Enum "
Private Const END_ENUM = "End Enum"
Private Const BEG_PB_ENUM = "Public Enum "
Private Const BEG_PV_ENUM = "Private Enum "

Private Const BEG_IF = "If "
Private Const END_IF = "End If"
Private Const BEG_WITH = "With "
Private Const END_WITH = "End With"

Private Const BEG_SELECT = "Select "
Private Const END_SELECT = "End Select"

Private Const BEG_FOR = "For "
Private Const END_FOR = "Next "
Private Const BEG_DOWHILE = "Do While "
Private Const BEG_DOUNTIL = "Do Until "
Private Const BEG_WHILE = "While "
Private Const END_WHILE = "Wend"

Private Const BEG_TYPE = "Type "
Private Const END_TYPE = "End Type"
Private Const BEG_PB_TYPE = "Public Type "
Private Const BEG_PV_TYPE = "Private Type "

' Single words that need to be handled separately
Private Const ONEWORD_END_FOR = "Next"
Private Const ONEWORD_DO = "Do"
Private Const ONEWORD_END_LOOP = "Loop"
Private Const ONEWORD_ELSE = "Else"
Private Const BEG_END_ELSEIF = "ElseIf"
Private Const BEG_END_CASE = "Case "

Private Const THEN_KEYWORD = "Then"
Private Const LINE_CONTINUATION = " _"

Private Const INDENT = "    "
'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Scripting Runtime
Private words As Dictionary 'Keys are Strings, Value is an Integer indicating change in indentation
Private indentation(0 To 20) As Variant ' Prevent repeatedly building the same strings by looking them up in here

' 3-state data type for checking if part of code is within a string or not
Private Enum StringStatus
    InString
    MaybeInString
    NotInString
End Enum

Private Sub initialize()
    initializeWords
    initializeIndentation
End Sub

Private Sub initializeIndentation()
    Dim indentString As String
    indentString = ""
    Dim i As Integer
    For i = 0 To UBound(indentation)
        indentation(i) = indentString
        indentString = indentString & INDENT
    Next
End Sub

Private Sub initializeWords()
    Dim w As Dictionary
    Set w = New Dictionary

    w.Add BEG_SUB, 1
    w.Add END_SUB, -1
    w.Add BEG_PB_SUB, 1
    w.Add BEG_PV_SUB, 1
    w.Add BEG_FR_SUB, 1
    w.Add BEG_PB_ST_SUB, 1
    w.Add BEG_PV_ST_SUB, 1
    w.Add BEG_FR_ST_SUB, 1

    w.Add BEG_FUN, 1
    w.Add END_FUN, -1
    w.Add BEG_PB_FUN, 1
    w.Add BEG_PV_FUN, 1
    w.Add BEG_FR_FUN, 1
    w.Add BEG_PB_ST_FUN, 1
    w.Add BEG_PV_ST_FUN, 1
    w.Add BEG_FR_ST_FUN, 1

    w.Add BEG_PROP, 1
    w.Add END_PROP, -1
    w.Add BEG_PB_PROP, 1
    w.Add BEG_PV_PROP, 1
    w.Add BEG_FR_PROP, 1
    w.Add BEG_PB_ST_PROP, 1
    w.Add BEG_PV_ST_PROP, 1
    w.Add BEG_FR_ST_PROP, 1

    w.Add BEG_ENUM, 1
    w.Add END_ENUM, -1
    w.Add BEG_PB_ENUM, 1
    w.Add BEG_PV_ENUM, 1

    w.Add BEG_IF, 1
    w.Add END_IF, -1
    'because any following 'Case' indents to the left we jump two
    w.Add BEG_SELECT, 2
    w.Add END_SELECT, -2
    w.Add BEG_WITH, 1
    w.Add END_WITH, -1

    w.Add BEG_FOR, 1
    w.Add END_FOR, -1
    w.Add BEG_DOWHILE, 1
    w.Add BEG_DOUNTIL, 1
    w.Add BEG_WHILE, 1
    w.Add END_WHILE, -1

    w.Add BEG_TYPE, 1
    w.Add END_TYPE, -1
    w.Add BEG_PB_TYPE, 1
    w.Add BEG_PV_TYPE, 1

    Set words = w
End Sub


Private Property Get vbaWords() As Dictionary
    If words Is Nothing Then
        initialize
    End If
    Set vbaWords = words
End Property

Public Sub testFormatting()
    If words Is Nothing Then
        initialize
    End If
    'Debug.Print Application.VBE.ActiveCodePane.codePane.Parent.Name
    'Debug.Print Application.VBE.ActiveWindow.caption

    Dim projName As String, moduleName As String
    projName = "vbaDeveloper"
    moduleName = "Test"
    'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Visual basic for application Extensibility 5.3
    Dim vbaProject As VBProject
    Set vbaProject = Application.VBE.VBProjects(projName)
    Dim code As CodeModule
    Set code = vbaProject.VBComponents(moduleName).CodeModule

    'removeIndentation code
    'formatCode code
    formatProject vbaProject
End Sub
'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Visual basic for application Extensibility 5.3
Public Sub formatProject(vbaProject As VBProject)
    Dim codePane As CodeModule

    Dim component As Variant
    For Each component In vbaProject.VBComponents
        Set codePane = component.CodeModule
        Debug.Print "Formatting " & component.Name
        formatCode codePane
    Next
End Sub

Public Sub format()
    formatCode Application.VBE.ActiveCodePane.CodeModule
End Sub


Public Sub formatCode(codePane As CodeModule)
    On Error GoTo formatCodeError
    Dim lineCount As Integer
    lineCount = codePane.CountOfLines

    Dim indentLevel As Integer, nextLevel As Integer, levelChange As Integer, isPrevLineContinuated As Boolean
    indentLevel = 0
    isPrevLineContinuated = False
    Dim lineNr As Integer
    For lineNr = 1 To lineCount
        Dim line As String
        line = Trim(codePane.Lines(lineNr, 1))
        If Not line = "" Then
            If isEqual(ONEWORD_ELSE, line) _
                Or lineStartsWith(BEG_END_ELSEIF, line) _
                Or lineStartsWith(BEG_END_CASE, line) Then
                ' Case, Else, ElseIf need to jump to the left
                levelChange = 1
                indentLevel = -1 + indentLevel
            ElseIf isLabel(line) Then
                ' Labels don't have indentation
                levelChange = indentLevel
                indentLevel = 0
                ' check for oneline If statemts
            ElseIf isOneLineIfStatemt(line) Then
                levelChange = 0
            Else
                levelChange = indentChange(line)
            End If

            nextLevel = indentLevel + levelChange
            If levelChange <= -1 Then
                indentLevel = nextLevel
            End If

            line = indentation(indentLevel) + line
            indentLevel = nextLevel
        End If
        If Not isPrevLineContinuated Then
            Call codePane.ReplaceLine(lineNr, line)
        End If
        isPrevLineContinuated = isLineContinuated(line)
    Next
    Exit Sub
formatCodeError:
    Debug.Print "Error while formatting " & codePane.Parent.Name
    Debug.Print Err.Number & " " & Err.Description
    Debug.Print " on line " & lineNr & ": " & line
    Debug.Print "indentLevel: " & indentLevel & " , levelChange: " & levelChange
End Sub


Public Sub removeIndentation(codePane As CodeModule)
    Dim lineCount As Integer
    lineCount = codePane.CountOfLines

    Dim lineNr As Integer
    For lineNr = 1 To lineCount
        Dim line As String
        line = codePane.Lines(lineNr, 1)
        line = Trim(line)
        Call codePane.ReplaceLine(lineNr, line)
    Next
End Sub

Private Function indentChange(ByVal line As String) As Integer
    indentChange = 0
    Dim w As Dictionary
    Set w = vbaWords

    If isEqual(line, ONEWORD_END_FOR) Or _
        lineStartsWith(ONEWORD_END_LOOP, line) Then
        indentChange = -1
        GoTo hell
    End If
    If isEqual(ONEWORD_DO, line) Then
        indentChange = 1
        GoTo hell
    End If
    Dim word As String
    Dim vord As Variant
    For Each vord In w.keys
        word = vord 'Cast the Variant to a String
        If lineStartsWith(word, line) Then
            indentChange = vbaWords(word)
            GoTo hell
        End If
    Next
hell:
End Function

' Returns true if both strings are equal, ignoring case
Private Function isEqual(first As String, second As String) As Boolean
    isEqual = (StrComp(first, second, vbTextCompare) = 0)
End Function

' Returns True if strToCheck begins with begin, ignoring case
Private Function lineStartsWith(begin As String, strToCheck As String) As Boolean
    lineStartsWith = False
    Dim beginLength As Integer
    beginLength = Len(begin)
    If Len(strToCheck) >= beginLength Then
        lineStartsWith = isEqual(begin, Left(strToCheck, beginLength))
    End If
End Function


' Returns True if strToCheck ends with ending, ignoring case
Private Function lineEndsWith(ending As String, strToCheck As String) As Boolean
    lineEndsWith = False
    Dim length As Integer
    length = Len(ending)
    If Len(strToCheck) >= length Then
        lineEndsWith = isEqual(ending, Right(strToCheck, length))
    End If
End Function


Private Function isLabel(line As String) As Boolean
    'it must end with a colon: and may not contain a space.
    isLabel = (Right(line, 1) = ":") And (InStr(line, " ") < 1)
End Function


Private Function isOneLineIfStatemt(line As String) As Boolean
    Dim trimmedLine As String
    trimmedLine = TrimComments(line)
    isOneLineIfStatemt = (lineStartsWith(BEG_IF, trimmedLine) And (Not lineEndsWith(THEN_KEYWORD, trimmedLine)) And Not lineEndsWith(LINE_CONTINUATION, trimmedLine))
End Function


Private Function isLineContinuated(line As String) As Boolean
    Dim trimmedLine As String
    trimmedLine = TrimComments(line)
    isLineContinuated = lineEndsWith(LINE_CONTINUATION, trimmedLine)
End Function


' Trims trailing comments (and whitespace before a comment) from a line of code
Private Function TrimComments(ByVal line As String) As String
    Dim c               As Long
    Dim inQuotes        As StringStatus
    Dim inComment       As Boolean

    inQuotes = NotInString
    inComment = False
    For c = 1 To Len(line)
        If Mid(line, c, 1) = Chr(34) Then
            ' Found a double quote
            Select Case inQuotes
                Case NotInString:
                    inQuotes = InString
                Case InString:
                    inQuotes = MaybeInString
                Case MaybeInString:
                    inQuotes = InString
            End Select
        Else
            ' Resolve uncertain string status
            If inQuotes = MaybeInString Then
                inQuotes = NotInString
            End If
        End If
        ' Now know as much about status inside double quotes as possible, can test for comment
        If inQuotes = NotInString And Mid(line, c, 1) = "'" Then
            inComment = True
            Exit For
        End If
    Next c
    If inComment Then
        TrimComments = Trim(Left(line, c - 1))
    Else
        TrimComments = line
    End If
End Function

'FORMAT
'====================================================================

'====================================================================
'Excel VBA
'MUST ADD=>TOOLS=>REFERENCE=>Microsoft Excel 16.0 Object Library
Function ws_exist(wb As Workbook, wsn As String) As Boolean
    '本函数用于判断工作簿中是否存在指定工作表
    Dim ws As Worksheet
    ws_exist = False
    For Each ws In wb.Worksheets
        If ws.Name = wsn Then
            ws_exist = True
            Exit Function
        End If
    Next
End Function

Function get_ws(ByRef wb As Workbook, ByVal wsname As String) As Worksheet
    On Error GoTo errorhand
    Dim i As Integer
    Dim havewsT As Boolean
    havewsT = False
    For i = 1 To wb.Worksheets.Count
        If wb.Worksheets(i).Name = wsname Then
            Set get_ws = wb.Worksheets(i)
            havewsT = True
        End If
    Next
    If havewsT = False Then
        wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = wsname
        Set get_ws = wb.Worksheets(wsname)
    End If
    Exit Function
errorhand:
    If Err.Number <> 0 Then MsgBox "get_ws function: " + Err.Description
    Err.Clear
End Function

Function add_comm(ByVal comm_s As String, ws1 As Worksheet, ByVal h_i As Integer, ByVal l_i As Integer, ByVal visiable As Boolean) As Boolean
    On Error GoTo errorhand
    If ws1.Cells(h_i, l_i).comment Is Nothing Then
        ws1.Cells(h_i, l_i).AddComment
    End If
    ws1.Cells(h_i, l_i).comment.Text Text:=comm_s
    ws1.Cells(h_i, l_i).comment.Visible = visiable
    Exit Function
errorhand:
    If Err.Number <> 0 Then MsgBox "get_ws function: " + Err.Description
    Err.Clear
End Function

Function add_comment(ByVal comm_s As String, tar_rg As Range) As Boolean
    On Error GoTo errorhand

    If tar_rg.comment Is Nothing Then
        tar_rg.AddComment
    End If
    tar_rg.comment.Text Text:=comm_s
    tar_rg.comment.Visible = True
    Exit Function
errorhand:
    If Err.Number <> 0 Then MsgBox "get_ws function: " + Err.Description
    Err.Clear
End Function

Function open_wb2(ByRef wb As Workbook, ByVal flfp As String) As Boolean
    '==========================================================
    '在新窗口中打开 workbook
    '==========================================================
    open_wb2 = False

    Dim app As Object
    Set app = CreateObject("Excel.application")
    app.Visible = True


    Dim i As Integer
    Dim fln, flp As String
    fln = Right(flfp, Len(flfp) - InStrRev(flfp, "\"))
    flp = Left(flfp, Len(flfp) - Len(fln))
    Dim temp_b As Boolean
    temp_b = False
    For i = 1 To app.Workbooks.Count
        If app.Workbooks(i).Name = fln Then
            temp_b = True
            Set wb = app.Workbooks(i)
            Exit For
        End If
    Next
    If temp_b = False Then
        If Dir(flp & fln) <> "" Then

            On Error GoTo Error1:
            Set wb = app.Workbooks.Open(flp & fln)

            temp_b = True
        End If
    End If
    open_wb2 = temp_b
    Exit Function
Error1:
    MsgBox "open_wb2 function:" + Err.Description
    Err.Clear
    Exit Function

End Function

Function Close_wb2(ByRef wb As Workbook) As Boolean
    '==========================================================
    '在新窗口中打开 workbook
    '==========================================================
    On Error GoTo errorhand
    Dim app As Object
    Set app = wb.Application
    If wb.Application.Workbooks.Count = 1 Then
        wb.Close
        app.Quit
        Set app = Nothing
    End If
    Exit Function
errorhand:
    MsgBox "Close_wb2 function:" + Err.Description
    Err.Clear
End Function

Function Str_TO_Num(in_s As String, ByRef out_i As Integer) As Boolean
    '本函数用于字符串转数字
    On Error GoTo errorhand
    Str_TO_Num = True
    out_i = CInt(in_s)
    Exit Function
errorhand:
    Str_TO_Num = False
    'MsgBox "Str_TO_Num:" + Err.Description
    Err.Clear
End Function

Function Str_TO_Dbl(in_s As String, ByRef out_dbl As Double) As Boolean
    '本函数用于字符串转数字
    On Error GoTo errorhand
    Str_TO_Dbl = True
    out_dbl = CDbl(in_s)
    Exit Function
errorhand:
    Str_TO_Dbl = False
    'MsgBox "Str_TO_Num:" + Err.Description
    Err.Clear
End Function

Function append_ws(ByRef ws As Worksheet, ByVal a As String, ByVal A_val) As Integer
    append_ws = 0
    Dim lastrow As Integer
    lastrow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
    ws.Range(a & lastrow + 1) = A_val
    append_ws = lastrow + 1

End Function

Function GetColName(ByVal intCol As Long) As String
    '列号转列名
    If InStr(CStr(Application.Version), "11") > 0 And intCol >= 1 And intCol <= 256 Then
        GetColName = Split(Workbooks(1).Worksheets(1).Cells(1, intCol).Address, "$")(1)
    ElseIf InStr(CStr(Application.Version), "12") > 0 And intCol >= 1 And intCol <= 16384 Then
        GetColName = Split(Workbooks(1).Worksheets(1).Cells(1, intCol).Address, "$")(1)

    ElseIf InStr(CStr(Application.Version), "14") > 0 And intCol >= 1 And intCol <= 16384 Then
        GetColName = Split(Workbooks(1).Worksheets(1).Cells(1, intCol).Address, "$")(1)

    Else

        GetColName = "Error"
    End If
End Function

Function my_cint(str1 As String) As Integer
    On Error GoTo ErrorH
    my_cint = CInt(str1)
    Exit Function
ErrorH:
    my_cint = 0
End Function

Function my_msgbox(str1 As String, Optional tf As Boolean = True) As VbMsgBoxResult
    my_msgbox = MsgBox(str1, tf)
End Function

Function rg_scrowll(rg As Range)
    '滚动到指定单元格
    Dim ws As Worksheet
    Dim i_r As Integer, i_c As Integer, i_wr As Integer, I_wc As Integer
    Set ws = rg.Parent
    ws.Activate
    i_r = rg.Row
    i_c = rg.Column
    i_wr = ActiveWindow.VisibleRange.Row
    I_wc = ActiveWindow.VisibleRange.Column
    If i_r - i_wr = 0 Then
    Else
        ActiveWindow.SmallScroll Down:=i_r - i_wr
    End If
    If i_c - I_wc = 0 Then
    Else
        ActiveWindow.SmallScroll ToRight:=i_c - I_wc
    End If
End Function

Function check_cell(rg As Range, s_desir As String) As Boolean
    '检查单元格是否为指定内容，如果不是，标红，并在在备注提示
    Dim s_temp As String
    s_temp = rg.Text
    If s_temp = s_desir Then
        check_cell = True
    Else
        check_cell = False
        If rg.comment Is Nothing Then
            rg.AddComment
        End If
        rg.comment.Text Text:=s_desir
        rg.comment.Visible = True
    End If
End Function

Function open_wb(ByRef wb As Workbook, ByVal flfp As String) As Boolean
    '==========================================================
    'Open File(*.xls*):  Microsoft Excel
    '==========================================================
    open_wb = False

    Dim i As Integer
    Dim fln, flp As String
    fln = Right(flfp, Len(flfp) - InStrRev(flfp, "\"))
    flp = Left(flfp, Len(flfp) - Len(fln))
    Dim temp_b As Boolean
    temp_b = False
    For i = 1 To Workbooks.Count
        If Workbooks(i).Name = fln Then
            temp_b = True
            Set wb = Workbooks(i)
            Exit For
        End If
    Next
    If temp_b = False Then
        If Dir(flp & fln) <> "" Then

            On Error GoTo Error1:
            Set wb = Workbooks.Open(flp & fln)

            temp_b = True
        End If
    End If
    open_wb = temp_b
    Exit Function
Error1:
    MsgBox "open_wb function:" + Err.Description
    Err.Clear
    Exit Function

End Function

Function write_para(wb As Workbook, comment As String, Optional para_v As String = "") As String
    '在SETTING工作表A列中找备注为所给备注的单元格，要求输入
    Dim ws As Worksheet, str1 As String
    Set ws = get_ws(wb, "SETTING")
    Dim i As Integer, i_last As Integer
    i_last = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
    For i = 1 To i_last
        If ws.Range("A" & i).comment Is Nothing Then
        Else
            If ws.Range("A" & i).comment.Text = comment Then
                ws.Range("A" & i) = para_v
                Exit Function
            End If
        End If
    Next
    add_comment comment, ws.Range("A" & i)
    ws.Range("A" & i) = para_v
End Function

Function get_para_rg(rg As Range, comment As String, Optional s_input As String = "Y") As String
    Dim rg1 As Range, rg2 As Range
    Dim b1 As Boolean, b2 As Boolean
    get_para_rg = ""
    b1 = False
    b2 = False
    For Each rg1 In rg
        If rg1.comment Is Nothing Then
            If b2 = False Then
                Set rg2 = rg1
                b2 = True
            End If
        Else
            If rg1.comment.Text = comment Then
                If s_input = "Y" Then
                    get_para_rg = InputBox(comment, "GET_PARA", rg1)
                    rg1 = get_para_rg
                    Exit Function
                Else
                    get_para_rg = rg1
                    Exit Function
                End If
            End If
        End If
    Next
    If s_input = "Y" Then
        If b2 Then
            add_comment comment, rg2
            get_para_rg = InputBox(comment, "GET_PARA", rg2)
            rg2 = get_para_rg
        Else
            MsgBox "NO Empty Cell for Para!"
            get_para_rg = ""
        End If
    End If
End Function

Function write_para_rg(rg As Range, comment As String, Optional para_v As String = "") As String
    Dim rg1 As Range, rg2 As Range
    Dim b1 As Boolean, b2 As Boolean
    b1 = False
    b2 = False
    For Each rg1 In rg
        If rg1.comment Is Nothing Then
            If b2 = False Then
                Set rg2 = rg1
                b2 = True
            End If
        Else
            If rg1.comment.Text = comment Then
                rg1 = para_v
                Exit Function
            End If
        End If
    Next
    If b2 Then
        add_comment comment, rg2
        rg2 = para_v
    Else
        MsgBox "NO Empty Cell for Para!"
        write_para_rg = ""
    End If
End Function

Function P_SPLIT(ByVal txtRange, ByVal splitter As String, Optional ByVal get_index As Integer = 0)
    '拆分字符串，
    'get_index=0    则返回被拆分出来的第一个字符串
    'get_index=1，2，3    则返回被拆分出来的第二、三、四个字符传
    'get_index=-1，-2，-3    则返回被拆分出来的倒数第一、二、三个字符传
    '越界返回 ""
    Dim a As Variant
    Dim b As Variant
    Dim c As Variant
    a = Split(txtRange, splitter)
    b = LBound(a)
    c = UBound(a)
    If get_index = -1 Then
        P_SPLIT = a(c)
    ElseIf get_index = 0 Then
        P_SPLIT = a(b)
    ElseIf get_index >= b And get_index <= c Then
        P_SPLIT = a(get_index)
    ElseIf get_index <= -1 And get_index >= -1 * c - 1 Then
        P_SPLIT = a(c + 1 + get_index)
    Else
        P_SPLIT = ""
    End If
End Function



Sub IN_CFSO()
    Dim codes As String, b_nothing As Boolean, wb As Workbook, md As Object, s_str3 As String
    Set wb = ThisWorkbook
    s_str3 = "CFSO"
    b_nothing = True
    For Each md In wb.VBProject.VBComponents
        If md.Name = s_str3 Then b_nothing = False
    Next
    If b_nothing Then
        wb.VBProject.VBComponents.Add(vbext_ct_ClassModule).Name = s_str3
    Else
        wb.VBProject.VBComponents(s_str3).CodeModule.DeleteLines 1, wb.VBProject.VBComponents(s_str3).CodeModule.CountOfLines
    End If
    With wb.VBProject.VBComponents(s_str3).CodeModule
        .InsertLines 1, "Option Explicit"
        .InsertLines 2, "Private Fso As Object"
        .InsertLines 3, "Public Function folderexists(fdn As String) As Boolean"
        .InsertLines 4, "    folderexists = False"
        .InsertLines 5, "    If Fso.folderexists(fdn) Then"
        .InsertLines 6, "        folderexists = True"
        .InsertLines 7, "    End If"
        .InsertLines 8, "End Function"
        .InsertLines 9, "Public Function FileExists(flfp As String) As Boolean"
        .InsertLines 10, "    FileExists = False"
        .InsertLines 11, "    If Fso.FileExists(flfp) Then"
        .InsertLines 12, "        FileExists = True"
        .InsertLines 13, "    End If"
        .InsertLines 14, "End Function"
        .InsertLines 15, "Public Function PickFolder() As String"
        .InsertLines 16, "    Dim fd As FileDialog"
        .InsertLines 17, "    Dim strPath As String"
        .InsertLines 18, "    Set fd = Application.FileDialog(msoFileDialogFolderPicker)"
        .InsertLines 19, "    If fd.Show = -1 Then"
        .InsertLines 20, "        strPath = fd.SelectedItems(1)"
        .InsertLines 21, "    Else"
        .InsertLines 22, "        strPath = """""
        .InsertLines 23, "    End If"
        .InsertLines 24, "    Set fd = Nothing"
        .InsertLines 25, "    PickFolder = strPath"
        .InsertLines 26, "End Function"
        .InsertLines 27, "Function CopyFolder(fd_f As String, fd_t As String) As Boolean"
        .InsertLines 28, "    If folderexists(fd_f) And folderexists(fd_t) Then"
        .InsertLines 29, "        Fso.CopyFolder fd_f, fd_t"
        .InsertLines 30, "    End If"
        .InsertLines 31, "End Function"
        .InsertLines 32, "Private Sub Class_Initialize()"
        .InsertLines 33, "    Set Fso = CreateObject(""Scripting.FileSystemObject"")"
        .InsertLines 34, "End Sub"
        .InsertLines 35, "Private Sub Class_Terminate()"
        .InsertLines 36, "    Set Fso = Nothing"
        .InsertLines 37, "End Sub"
        .InsertLines 38, "Public Function CreateFolder(ByVal strPath)"
        .InsertLines 39, "    On Error Resume Next"
        .InsertLines 40, "    Dim arrPath, pathNum, i, tmpPath, currPath"
        .InsertLines 41, "    strPath = Replace(strPath, ""\"", ""/"")"
        .InsertLines 42, "    arrPath = Split(strPath, ""/"")"
        .InsertLines 43, "    pathNum = UBound(arrPath)"
        .InsertLines 44, "    If Err <> 0 Then"
        .InsertLines 45, "        MsgBox ""ERROR"""
        .InsertLines 46, "    End If"
        .InsertLines 47, "    For i = 0 To pathNum"
        .InsertLines 48, "        If i = 0 Then"
        .InsertLines 49, "            tmpPath = arrPath(0) & ""/"""
        .InsertLines 50, "        Else"
        .InsertLines 51, "            tmpPath = tmpPath & arrPath(i) & ""/"""
        .InsertLines 52, "        End If"
        .InsertLines 53, "        currPath = Left(tmpPath, Len(tmpPath) - 1)"
        .InsertLines 54, "        If Not Fso.folderexists(currPath) Then Fso.CreateFolder currPath"
        .InsertLines 55, "    Next"
        .InsertLines 56, "End Function"
        .InsertLines 57, ""
        .InsertLines 58, "Public Function Datelastmodify(flfp As String) As Date"
        .InsertLines 59, "    If folderexists(flfp) Then"
        .InsertLines 60, "        Datelastmodify = Fso.getfolder(flfp).DateLastModified"
        .InsertLines 61, "    ElseIf FileExists(flfp) Then"
        .InsertLines 62, "        Datelastmodify = Fso.GetFile(flfp).DateLastModified"
        .InsertLines 63, "    Else"
        .InsertLines 64, "        Datelastmodify = CDate(""1900-1-1"")"
        .InsertLines 65, "    End If"
        .InsertLines 66, "End Function"
        .InsertLines 67, ""
        .InsertLines 68, "Public Function Userlastmodify(flfp As String) As String"
        .InsertLines 69, "    Userlastmodify = """""
        .InsertLines 70, "    On Error GoTo Err:"
        .InsertLines 71, "    If flfp Like ""*.xls*"" Then"
        .InsertLines 72, "        Dim wb As Workbook"
        .InsertLines 73, "        If open_wb(wb, flfp) Then"
        .InsertLines 74, "            Userlastmodify = wb.BuiltinDocumentProperties.Item(""Last author"").Value"
        .InsertLines 75, "            wb.Saved = True"
        .InsertLines 76, "            wb.Close"
        .InsertLines 77, "        End If"
        .InsertLines 78, "    End If"
        .InsertLines 79, "    Exit Function"
        .InsertLines 80, "Err:"
        .InsertLines 81, "    MsgBox ""FSO ERR:Userlastmodify"" & Err.Number"
        .InsertLines 82, "End Function"
        .InsertLines 83, ""
        .InsertLines 84, "Public Function copy_file(ByVal flfp_from As String, ByVal flfp_to As String) As Boolean"
        .InsertLines 85, "    On Error GoTo errorhand"
        .InsertLines 86, "    copy_file = False"
        .InsertLines 87, "    Dim fdn As String"
        .InsertLines 88, "    Dim fln As String"
        .InsertLines 89, "    Dim fdn_from As String"
        .InsertLines 90, "    Dim fln_to As String"
        .InsertLines 91, "    fdn = Left(flfp_to, InStrRev(flfp_to, ""\""))"
        .InsertLines 92, "    fdn_from = Left(flfp_from, InStrRev(flfp_from, ""\""))"
        .InsertLines 93, "    fln = Right(flfp_from, Len(flfp_from) - Len(fdn_from))"
        .InsertLines 94, "    If Right(flfp_to, 1) = ""\"" Then"
        .InsertLines 95, "        fln_to = fln"
        .InsertLines 96, "    Else"
        .InsertLines 97, "        fln_to = """""
        .InsertLines 98, "    End If"
        .InsertLines 99, "    CreateFolder fdn"
        .InsertLines 100, "    If Fso.FileExists(flfp_from) = True Then"
        .InsertLines 101, "        Fso.CopyFile flfp_from, flfp_to & fln_to, True"
        .InsertLines 102, "        copy_file = True"
        .InsertLines 103, "    End If"
        .InsertLines 104, "    Exit Function"
        .InsertLines 105, "errorhand:"
        .InsertLines 106, "    If Err.Number = 70 Then"
        .InsertLines 107, "        Application.Wait (Now() + TimeValue(""00:00:01""))"
        .InsertLines 108, "        If FileExists(flfp_to) = False Then"
        .InsertLines 109, "            copy_file flfp_from, flfp_to"
        .InsertLines 110, "        End If"
        .InsertLines 111, "    Else"
        .InsertLines 112, "        MsgBox Err.Description & ""copy_file"""
        .InsertLines 113, "    End If"
        .InsertLines 114, "End Function"
        .InsertLines 115, ""
        .InsertLines 116, "Public Function deletefile(str1 As String) As Boolean"
        .InsertLines 117, "    On Error GoTo errorhand"
        .InsertLines 118, "    deletefile = True"
        .InsertLines 119, "    Fso.deletefile str1"
        .InsertLines 120, "    Exit Function"
        .InsertLines 121, "errorhand:"
        .InsertLines 122, "    deletefile = False"
        .InsertLines 123, "End Function"
        .InsertLines 124, "Public Function GetFiles(path$, Optional Fullname As Boolean = True, Optional ftype_f_fo = ""f"", Optional digui As Boolean = True)"
        .InsertLines 125, "    Dim dic As Object, i&"
        .InsertLines 126, "    Set dic = CreateObject(""Scripting.Dictionary"")"
        .InsertLines 127, "    Dim Fso As Object, Folder As Object"
        .InsertLines 128, "    Set Fso = CreateObject(""Scripting.FileSystemObject"")"
        .InsertLines 129, "    Set Folder = Fso.getfolder(path)"
        .InsertLines 130, "    i = 1"
        .InsertLines 131, "    Call aGetFile(Folder, dic, ftype_f_fo, digui)"
        .InsertLines 132, "    If Fullname Then"
        .InsertLines 133, "        GetFiles = dic.Keys"
        .InsertLines 134, "    Else"
        .InsertLines 135, "        GetFiles = dic.items"
        .InsertLines 136, "    End If"
        .InsertLines 137, "    Set Folder = Nothing"
        .InsertLines 138, "    Set Fso = Nothing"
        .InsertLines 139, "End Function"
        .InsertLines 140, "Private Function aGetFile(ByVal Folder As Object, dic, Optional ftype = ""f"", Optional digui As Boolean = True)"
        .InsertLines 141, "    Dim SubFolder As Object"
        .InsertLines 142, "    Dim File As Object"
        .InsertLines 143, "    If ftype = ""fo"" Then"
        .InsertLines 144, "        For Each SubFolder In Folder.SubFolders"
        .InsertLines 145, "            dic.Add SubFolder.path, SubFolder.Name"
        .InsertLines 146, "            If digui Then Call aGetFile(SubFolder, dic, ftype)"
        .InsertLines 147, "        Next"
        .InsertLines 148, "    Else"
        .InsertLines 149, "        For Each File In Folder.Files"
        .InsertLines 150, "            If InStr(File.path, File.Name) = Len(File.path) - Len(File.Name) + 1 Then"
        .InsertLines 151, "                dic.Add File.path & """", File.Name"
        .InsertLines 152, "            Else"
        .InsertLines 153, "                dic.Add File.path & """" & File.Name, File.Name"
        .InsertLines 154, "            End If"
        .InsertLines 155, "        Next"
        .InsertLines 156, "        For Each SubFolder In Folder.SubFolders"
        .InsertLines 157, "            If digui Then Call aGetFile(SubFolder, dic, ftype)"
        .InsertLines 158, "        Next"
        .InsertLines 159, "    End If"
        .InsertLines 160, "End Function"
        .InsertLines 161, "Function get_flndatesize(flfp As String) As String"
        .InsertLines 162, "    On Error GoTo errorhand"
        .InsertLines 163, "    Dim fobj As Object"
        .InsertLines 164, "    Set fobj = Fso.GetFile(flfp)"
        .InsertLines 165, "    get_flndatesize = fobj.Name & ""_"" & format(fobj.DateLastModified, ""YYYYMMDDHHMMSS"") & ""_"" & fobj.Size"
        .InsertLines 166, "    Exit Function"
        .InsertLines 167, "errorhand:"
        .InsertLines 168, "    get_flndatesize = """""
        .InsertLines 169, "End Function"
        .InsertLines 170, "Function DeleteFolder(fd_del As String) As Boolean"
        .InsertLines 171, "    If folderexists(fd_del) = False Then"
        .InsertLines 172, "        DeleteFolder = True"
        .InsertLines 173, "        Exit Function"
        .InsertLines 174, "    Else"
        .InsertLines 175, "        Fso.DeleteFolder (fd_del)"
        .InsertLines 176, "        DoEvents"
        .InsertLines 177, "        DeleteFolder = Not (folderexists(fd_del))"
        .InsertLines 178, "    End If"
        .InsertLines 179, "End Function"
    End With
End Sub

Private Function get_VBComponents()
    On Error GoTo tryaccess
    Set get_VBComponents = ThisWorkbook.VBProject.VBComponents
    Exit Function
tryaccess:
    Set get_VBComponents = Application.VBE.VBProjects(1).VBComponents
    Exit Function
End Function

Sub IN_OKC()

    Dim codes As String, b_nothing As Boolean, wb As Workbook, md As Object, s_str3 As String
    Dim vbcs
    Set vbcs = get_VBComponents


    s_str3 = "OneKeyCls"
    b_nothing = True
    For Each md In vbcs
        If md.Name = s_str3 Then b_nothing = False
    Next
    If b_nothing Then
        vbcs.Add(vbext_ct_ClassModule).Name = s_str3
    Else
        vbcs(s_str3).CodeModule.DeleteLines 1, vbcs(s_str3).CodeModule.CountOfLines
    End If
    With vbcs(s_str3).CodeModule


        .InsertLines 1, ""
        .InsertLines 2, "Option Explicit"
        .InsertLines 3, ""
        .InsertLines 4, "Public key As String"
        .InsertLines 5, "Private mCol As Collection"
        .InsertLines 6, "Public Function Add(key As String, Optional skey As String) As OneKeyCls"
        .InsertLines 7, "Dim objNewMember As OneKeyCls"
        .InsertLines 8, "Set objNewMember = New OneKeyCls"
        .InsertLines 9, "objNewMember.key = key"
        .InsertLines 10, "If Len(skey) = 0 Then"
        .InsertLines 11, "mCol.Add objNewMember"
        .InsertLines 12, "Else"
        .InsertLines 13, "mCol.Add objNewMember, skey"
        .InsertLines 14, "End If"
        .InsertLines 15, "Set Add = objNewMember"
        .InsertLines 16, "Set objNewMember = Nothing"
        .InsertLines 17, "End Function"
        .InsertLines 18, "Public Property Get Item(vntIndexKey As Variant) As OneKeyCls"
        .InsertLines 19, "Err.Clear"
        .InsertLines 20, "On Error GoTo GetItemError"
        .InsertLines 21, "Set Item = mCol(vntIndexKey)"
        .InsertLines 22, "Exit Property"
        .InsertLines 23, "GetItemError:"
        .InsertLines 24, "Debug.Print Err.Source & "" : Error Was found in Item(vntIndexKey as Variant) as oneKeyCls . "" & vbCrLf & Err.Description & "" : "" & Err.Number"
        .InsertLines 25, "Set Item = Nothing"
        .InsertLines 26, "End Property"
        .InsertLines 27, "Public Property Get Count() As Long"
        .InsertLines 28, "Count = mCol.Count"
        .InsertLines 29, "End Property"
        .InsertLines 30, "Public Sub Remove(vntIndexKey As Variant)"
        .InsertLines 31, "mCol.Remove vntIndexKey"
        .InsertLines 32, "End Sub"
        .InsertLines 33, "Public Property Get NewEnum() As IUnknown"
        .InsertLines 34, "Set NewEnum = mCol.[_NewEnum]"
        .InsertLines 35, "End Property"
        .InsertLines 36, "Private Sub Class_Initialize()"
        .InsertLines 37, "Set mCol = New Collection"
        .InsertLines 38, "End Sub"
        .InsertLines 39, "Private Sub Class_Terminate()"
        .InsertLines 40, "Set mCol = Nothing"
        .InsertLines 41, "End Sub"
        .InsertLines 42, "Public Function To_excel(fdn As String)"
        .InsertLines 43, "Dim mfso As New CFSO"
        .InsertLines 44, "If mfso.FileExists(fdn) = False Then"
        .InsertLines 45, "mfso.CreateFolder fdn"
        .InsertLines 46, "End If"
        .InsertLines 47, "Set mfso = Nothing"
        .InsertLines 48, "Dim mokc0 As OneKeyCls"
        .InsertLines 49, "Dim wb As Workbook"
        .InsertLines 50, "Dim i As Integer"
        .InsertLines 51, "If Right(fdn, 1) <> ""\"" Then fdn = fdn & ""\"""
        .InsertLines 52, "For Each mokc0 In mCol"
        .InsertLines 53, "Set wb = Workbooks.Add"
        .InsertLines 54, "wb.SaveAs fdn & Replace(mokc0.key, "":"", """") & "".xlsx"""
        .InsertLines 55, "If mokc0.Count > 0 Then"
        .InsertLines 56, "For i = 1 To mokc0.Count"
        .InsertLines 57, "wb.Worksheets(1).Range(""A"" & i) = mokc0.Item(i).key"
        .InsertLines 58, "Next"
        .InsertLines 59, "End If"
        .InsertLines 60, "wb.Save"
        .InsertLines 61, "wb.Saved = True"
        .InsertLines 62, "wb.Close"
        .InsertLines 63, "Set wb = Nothing"
        .InsertLines 64, "Next mokc0"
        .InsertLines 65, "End Function"
        .InsertLines 66, "Public Function To_excel_ws(ws As Worksheet)"
        .InsertLines 67, "Dim i As Long, j As Long"
        .InsertLines 68, "Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, j1 As Long, j2 As Long, j3 As Long, j4 As Long"
        .InsertLines 69, "i = 1"
        .InsertLines 70, "j = 1"
        .InsertLines 71, "Dim mokc0 As OneKeyCls"
        .InsertLines 72, "Dim mokc1 As OneKeyCls"
        .InsertLines 73, "If mCol.Count > 0 Then"
        .InsertLines 74, "        For Each mokc0 In mCol"
        .InsertLines 75, "            If mokc0.Count > 0 Then"
        .InsertLines 76, "                ws.Cells(i, j) = mokc0.key"
        .InsertLines 77, "                i = i + 1"
        .InsertLines 78, "                For i1 = 1 To mokc0.Count"
        .InsertLines 79, "                    If mokc0.Item(i1).Count > 0 Then"
        .InsertLines 80, "                        ws.Cells(i, 2) = mokc0.Item(i1).key"
        .InsertLines 81, "                        i = i + 1"
        .InsertLines 82, "                        For i2 = 1 To mokc0.Item(i1).Count"
        .InsertLines 83, "                            If mokc0.Item(i1).Item(i2).Count > 0 Then"
        .InsertLines 84, "                                ws.Cells(i, 3) = mokc0.Item(i1).Item(i2).key"
        .InsertLines 85, "                                i = i + 1"
        .InsertLines 86, "                                For i3 = 1 To mokc0.Item(i1).Item(i2).Count"
        .InsertLines 87, "                                    ws.Cells(i, 4) = mokc0.Item(i1).Item(i2).Item(i3).key"
        .InsertLines 88, "                                    i = i + 1"
        .InsertLines 89, "                                Next"
        .InsertLines 90, "                            Else"
        .InsertLines 91, "                                ws.Cells(i, 3) = mokc0.Item(i1).Item(i2).key"
        .InsertLines 92, "                                i = i + 1"
        .InsertLines 93, "                            End If"
        .InsertLines 94, "                        Next"
        .InsertLines 95, "                    Else"
        .InsertLines 96, "                        ws.Cells(i, 2) = mokc0.Item(i1).key"
        .InsertLines 97, "                        i = i + 1"
        .InsertLines 98, "                    End If"
        .InsertLines 99, "                Next"
        .InsertLines 100, "            Else"
        .InsertLines 101, "                ws.Cells(i, j) = mokc0.key"
        .InsertLines 102, "                i = i + 1"
        .InsertLines 103, "            End If"
        .InsertLines 104, "        Next mokc0"
        .InsertLines 105, "    End If"
        .InsertLines 106, "End Function"

    End With
End Sub


'20210917 查找工作表
Function find_ws_row(rg As Range, s_val As String) As Integer
    '在指定区域中查找值,找到的话,返回行数,找不到返回-1
    Dim rgres As Range
    Set rgres = rg.Find(What:=s_val, MatchCase:=False)
    If rgres Is Nothing Then
        find_ws_row = -1
    Else
        find_ws_row = rgres.Row
    End If
End Function

'20211019 追加备注
Function app_comment(ByVal comm_s As String, tar_rg As Range) As Boolean
    On Error GoTo errorhand

    If tar_rg.comment Is Nothing Then
        tar_rg.AddComment
    End If
    tar_rg.comment.Text Text:=comm_s & Chr(10) & tar_rg.comment.Text
    tar_rg.comment.Visible = True
    Exit Function
errorhand:
    If Err.Number <> 0 Then MsgBox "get_ws function: " + Err.Description
    Err.Clear

End Function





